home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLOBJ.C < prev    next >
Text File  |  1985-01-01  |  17KB  |  688 lines
  1. /* xlobj - xlisp object functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack;
  7. extern NODE *xlenv,*xlnewenv;
  8. extern NODE *s_stdout;
  9. extern NODE *self;
  10. extern NODE *class;
  11. extern NODE *object;
  12. extern NODE *new;
  13. extern NODE *isnew;
  14. extern NODE *msgcls;
  15. extern NODE *msgclass;
  16. extern int varcnt;
  17.  
  18. /* instance variable numbers for the class 'Class' */
  19. #define MESSAGES    0    /* list of messages */
  20. #define IVARS        1    /* list of instance variable names */
  21. #define CVARS        2    /* list of class variable names */
  22. #define CVALS        3    /* list of class variable values */
  23. #define SUPERCLASS    4    /* pointer to the superclass */
  24. #define IVARCNT        5    /* number of class instance variables */
  25. #define IVARTOTAL    6    /* total number of instance variables */
  26.  
  27. /* number of instance variables for the class 'Class' */
  28. #define CLASSSIZE    7
  29.  
  30. /* forward declarations */
  31. FORWARD NODE *xlgetivar();
  32. FORWARD NODE *xlsetivar();
  33. FORWARD NODE *xlivar();
  34. FORWARD NODE *xlcvar();
  35. FORWARD NODE *findmsg();
  36. FORWARD NODE *findvar();
  37. FORWARD NODE *defvars();
  38. FORWARD NODE *makelist();
  39.  
  40. /* xlclass - define a class */
  41. NODE *xlclass(name,vcnt)
  42.   char *name; int vcnt;
  43. {
  44.     NODE *sym,*cls;
  45.  
  46.     /* create the class */
  47.     sym = xlsenter(name);
  48.     cls = sym->n_symvalue = newnode(OBJ);
  49.     cls->n_obclass = class;
  50.     cls->n_obdata = makelist(CLASSSIZE);
  51.  
  52.     /* set the instance variable counts */
  53.     if (vcnt > 0) {
  54.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
  55.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
  56.     }
  57.  
  58.     /* set the superclass to 'Object' */
  59.     xlsetivar(cls,SUPERCLASS,object);
  60.  
  61.     /* return the new class */
  62.     return (cls);
  63. }
  64.  
  65. /* xlmfind - find the message binding for a message to an object */
  66. NODE *xlmfind(obj,msym)
  67.   NODE *obj,*msym;
  68. {
  69.     return (findmsg(obj->n_obclass,msym));
  70. }
  71.  
  72. /* xlxsend - send a message to an object */
  73. NODE *xlxsend(obj,msg,args)
  74.   NODE *obj,*msg,*args;
  75. {
  76.     NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;
  77.  
  78.     /* save the old environment */
  79.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  80.  
  81.     /* create a new stack frame */
  82.     oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);
  83.  
  84.     /* get the method for this message */
  85.     method.n_ptr = cdr(msg);
  86.  
  87.     /* make sure its a function or a subr */
  88.     if (!subrp(method.n_ptr) && !consp(method.n_ptr))
  89.     xlfail("bad method");
  90.  
  91.     /* bind the symbols 'self' and 'msgclass' */
  92.     xlbind(self,obj);
  93.     xlbind(msgclass,msgcls);
  94.  
  95.     /* evaluate the function call */
  96.     eargs.n_ptr = xlevlist(args);
  97.     if (subrp(method.n_ptr)) {
  98.     xlfixbindings();
  99.     val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
  100.     }
  101.     else {
  102.  
  103.     /* bind the formal arguments */
  104.     xlabind(car(method.n_ptr),eargs.n_ptr);
  105.     xlfixbindings();
  106.  
  107.     /* execute the code */
  108.     cptr.n_ptr = cdr(method.n_ptr);
  109.     while (cptr.n_ptr != NULL)
  110.         val.n_ptr = xlevarg(&cptr.n_ptr);
  111.     }
  112.  
  113.     /* restore the environment */
  114.     xlunbind(oldenv); xlnewenv = oldnewenv;
  115.  
  116.     /* after creating an object, send it the "isnew" message */
  117.     if (car(msg) == new && val.n_ptr != NULL) {
  118.     if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
  119.         xlfail("no method for the isnew message");
  120.     val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
  121.     }
  122.  
  123.     /* restore the previous stack frame */
  124.     xlstack = oldstk;
  125.  
  126.     /* return the result value */
  127.     return (val.n_ptr);
  128. }
  129.  
  130. /* xlsend - send a message to an object (message in arg list) */
  131. NODE *xlsend(obj,args)
  132.   NODE *obj,*args;
  133. {
  134.     NODE *msg;
  135.  
  136.     /* find the message binding for this message */
  137.     if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
  138.     xlfail("no method for this message");
  139.  
  140.     /* send the message */
  141.     return (xlxsend(obj,msg,args));
  142. }
  143.  
  144. /* xlobsym - find a class or instance variable for the current object */
  145. NODE *xlobsym(sym)
  146.   NODE *sym;
  147. {
  148.     NODE *obj;
  149.  
  150.     if ((obj = self->n_symvalue) != NULL && objectp(obj))
  151.     return (findvar(obj,sym));
  152.     else
  153.     return (NULL);
  154. }
  155.  
  156. /* mnew - create a new object instance */
  157. LOCAL NODE *mnew()
  158. {
  159.     NODE *oldstk,obj,*cls;
  160.  
  161.     /* create a new stack frame */
  162.     oldstk = xlsave(&obj,NULL);
  163.  
  164.     /* get the class */
  165.     cls = self->n_symvalue;
  166.  
  167.     /* generate a new object */
  168.     obj.n_ptr = newnode(OBJ);
  169.     obj.n_ptr->n_obclass = cls;
  170.     obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
  171.  
  172.     /* restore the previous stack frame */
  173.     xlstack = oldstk;
  174.  
  175.     /* return the new object */
  176.     return (obj.n_ptr);
  177. }
  178.  
  179. /* misnew - initialize a new class */
  180. LOCAL NODE *misnew(args)
  181.   NODE *args;
  182. {
  183.     NODE *oldstk,super,*obj;
  184.  
  185.     /* create a new stack frame */
  186.     oldstk = xlsave(&super,NULL);
  187.  
  188.     /* get the superclass if there is one */
  189.     if (args != NULL)
  190.     super.n_ptr = xlmatch(OBJ,&args);
  191.     else
  192.     super.n_ptr = object;
  193.     xllastarg(args);
  194.  
  195.     /* get the object */
  196.     obj = self->n_symvalue;
  197.  
  198.     /* store the superclass */
  199.     xlsetivar(obj,SUPERCLASS,super.n_ptr);
  200.     xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
  201.         getivcnt(super.n_ptr,IVARTOTAL);
  202.  
  203.     /* restore the previous stack frame */
  204.     xlstack = oldstk;
  205.  
  206.     /* return the new object */
  207.     return (obj);
  208. }
  209.  
  210. /* xladdivar - enter an instance variable */
  211. xladdivar(cls,var)
  212.   NODE *cls; char *var;
  213. {
  214.     NODE *ivar,*lptr;
  215.  
  216.     /* find the 'ivars' instance variable */
  217.     ivar = xlivar(cls,IVARS);
  218.  
  219.     /* add the instance variable */
  220.     lptr = newnode(LIST);
  221.     rplacd(lptr,car(ivar));
  222.     rplaca(ivar,lptr);
  223.     rplaca(lptr,xlsenter(var));
  224. }
  225.  
  226. /* entermsg - add a message to a class */
  227. LOCAL NODE *entermsg(cls,msg)
  228.   NODE *cls,*msg;
  229. {
  230.     NODE *ivar,*lptr,*mptr;
  231.  
  232.     /* find the 'messages' instance variable */
  233.     ivar = xlivar(cls,MESSAGES);
  234.  
  235.     /* lookup the message */
  236.     for (lptr = car(ivar); lptr != NULL; lptr = cdr(lptr))
  237.     if (car(mptr = car(lptr)) == msg)
  238.         return (mptr);
  239.  
  240.     /* allocate a new message entry if one wasn't found */
  241.     lptr = newnode(LIST);
  242.     rplacd(lptr,car(ivar));
  243.     rplaca(ivar,lptr);
  244.     rplaca(lptr,mptr = newnode(LIST));
  245.     rplaca(mptr,msg);
  246.  
  247.     /* return the symbol node */
  248.     return (mptr);
  249. }
  250.  
  251. /* answer - define a method for answering a message */
  252. LOCAL NODE *answer(args)
  253.   NODE *args;
  254. {
  255.     NODE *oldstk,arg,msg,fargs,code;
  256.     NODE *obj,*mptr,*fptr;
  257.  
  258.     /* create a new stack frame */
  259.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  260.  
  261.     /* initialize */
  262.     arg.n_ptr = args;
  263.  
  264.     /* message symbol, formal argument list and code */
  265.     msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
  266.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  267.     code.n_ptr = xlmatch(LIST,&arg.n_ptr);
  268.     xllastarg(arg.n_ptr);
  269.  
  270.     /* get the object node */
  271.     obj = self->n_symvalue;
  272.  
  273.     /* make a new message list entry */
  274.     mptr = entermsg(obj,msg.n_ptr);
  275.  
  276.     /* setup the message node */
  277.     rplacd(mptr,fptr = newnode(LIST));
  278.     rplaca(fptr,fargs.n_ptr);
  279.     rplacd(fptr,code.n_ptr);
  280.  
  281.     /* restore the previous stack frame */
  282.     xlstack = oldstk;
  283.  
  284.     /* return the object */
  285.     return (obj);
  286. }
  287.  
  288. /* mivars - define the list of instance variables */
  289. LOCAL NODE *mivars(args)
  290.   NODE *args;
  291. {
  292.     NODE *cls,*super;
  293.     int scnt;
  294.  
  295.     /* define the list of instance variables */
  296.     cls = defvars(args,IVARS);
  297.  
  298.     /* get the superclass instance variable count */
  299.     if ((super = xlgetivar(cls,SUPERCLASS)) != NULL)
  300.     scnt = getivcnt(super,IVARTOTAL);
  301.     else
  302.     scnt = 0;
  303.  
  304.     /* save the number of instance variables */
  305.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
  306.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;
  307.  
  308.     /* return the class */
  309.     return (cls);
  310. }
  311.  
  312. /* getivcnt - get the number of instance variables for a class */
  313. LOCAL int getivcnt(cls,ivar)
  314.   NODE *cls; int ivar;
  315. {
  316.     NODE *cnt;
  317.  
  318.     if ((cnt = xlgetivar(cls,ivar)) != NULL)
  319.     if (fixp(cnt))
  320.         return (cnt->n_int);
  321.     else
  322.         xlfail("bad value for instance variable count");
  323.     else
  324.     return (0);
  325. }
  326.  
  327. /* mcvars - define the list of class variables */
  328. LOCAL NODE *mcvars(args)
  329.   NODE *args;
  330. {
  331.     NODE *cls;
  332.  
  333.     /* define the list of class variables */
  334.     cls = defvars(args,CVARS);
  335.  
  336.     /* make a new list of values */
  337.     xlsetivar(cls,CVALS,makelist(varcnt));
  338.  
  339.     /* return the class */
  340.     return (cls);
  341. }
  342.  
  343. /* defvars - define a class or instance variable list */
  344. LOCAL NODE *defvars(args,varnum)
  345.   NODE *args; int varnum;
  346. {
  347.     NODE *oldstk,vars,*vptr,*cls,*sym;
  348.  
  349.     /* create a new stack frame */
  350.     oldstk = xlsave(&vars,NULL);
  351.  
  352.     /* get ivar list */
  353.     vars.n_ptr = xlmatch(LIST,&args);
  354.     xllastarg(args);
  355.  
  356.     /* get the class node */
  357.     cls = self->n_symvalue;
  358.  
  359.     /* check each variable in the list */
  360.     varcnt = 0;
  361.     for (vptr = vars.n_ptr;
  362.      consp(vptr);
  363.      vptr = cdr(vptr)) {
  364.  
  365.     /* make sure this is a valid symbol in the list */
  366.     if ((sym = car(vptr)) == NULL || !symbolp(sym))
  367.         xlfail("bad variable list");
  368.  
  369.     /* make sure its not already defined */
  370.     if (checkvar(cls,sym))
  371.         xlfail("multiply defined variable");
  372.  
  373.     /* count the variable */
  374.     varcnt++;
  375.     }
  376.  
  377.     /* make sure the list ended properly */
  378.     if (vptr != NULL)
  379.     xlfail("bad variable list");
  380.  
  381.     /* define the new variable list */
  382.     xlsetivar(cls,varnum,vars.n_ptr);
  383.  
  384.     /* restore the previous stack frame */
  385.     xlstack = oldstk;
  386.  
  387.     /* return the class */
  388.     return (cls);
  389. }
  390.  
  391. /* xladdmsg - add a message to a class */
  392. xladdmsg(cls,msg,code)
  393.   NODE *cls; char *msg; NODE *(*code)();
  394. {
  395.     NODE *mptr;
  396.  
  397.     /* enter the message selector */
  398.     mptr = entermsg(cls,xlsenter(msg));
  399.  
  400.     /* store the method for this message */
  401.     rplacd(mptr,newnode(SUBR));
  402.     cdr(mptr)->n_subr = code;
  403. }
  404.  
  405. /* getclass - get the class of an object */
  406. LOCAL NODE *getclass(args)
  407.   NODE *args;
  408. {
  409.     /* make sure there aren't any arguments */
  410.     xllastarg(args);
  411.  
  412.     /* return the object's class */
  413.     return (self->n_symvalue->n_obclass);
  414. }
  415.  
  416. /* obshow - show the instance variables of an object */
  417. LOCAL NODE *obshow(args)
  418.   NODE *args;
  419. {
  420.     NODE *fptr;
  421.  
  422.     /* get the file pointer */
  423.     fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
  424.     xllastarg(args);
  425.  
  426.     /* print the object's instance variables */
  427.     xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
  428.     xlterpri(fptr);
  429.  
  430.     /* return the object */
  431.     return (self->n_symvalue);
  432. }
  433.  
  434. /* defisnew - default 'isnew' method */
  435. LOCAL NODE *defisnew(args)
  436.   NODE *args;
  437. {
  438.     /* make sure there aren't any arguments */
  439.     xllastarg(args);
  440.  
  441.     /* return the object */
  442.     return (self->n_symvalue);
  443. }
  444.  
  445. /* sendsuper - send a message to an object's superclass */
  446. LOCAL NODE *sendsuper(args)
  447.   NODE *args;
  448. {
  449.     NODE *obj,*super,*msg;
  450.  
  451.     /* get the object */
  452.     obj = self->n_symvalue;
  453.  
  454.     /* get the object's superclass */
  455.     super = xlgetivar(obj->n_obclass,SUPERCLASS);
  456.  
  457.     /* find the message binding for this message */
  458.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NULL)
  459.     xlfail("no method for this message");
  460.  
  461.     /* send the message */
  462.     return (xlxsend(obj,msg,args));
  463. }
  464.  
  465. /* findmsg - find the message binding given an object and a class */
  466. LOCAL NODE *findmsg(cls,sym)
  467.   NODE *cls,*sym;
  468. {
  469.     NODE *lptr,*msg;
  470.  
  471.     /* start at the specified class */
  472.     msgcls = cls;
  473.  
  474.     /* look for the message in the class or superclasses */
  475.     while (msgcls != NULL) {
  476.  
  477.     /* lookup the message in this class */
  478.     for (lptr = xlgetivar(msgcls,MESSAGES);
  479.          lptr != NULL;
  480.          lptr = cdr(lptr))
  481.         if ((msg = car(lptr)) != NULL && car(msg) == sym)
  482.         return (msg);
  483.  
  484.     /* look in class's superclass */
  485.     msgcls = xlgetivar(msgcls,SUPERCLASS);
  486.     }
  487.  
  488.     /* message not found */
  489.     return (NULL);
  490. }
  491.  
  492. /* findvar - find a class or instance variable */
  493. LOCAL NODE *findvar(obj,sym)
  494.   NODE *obj,*sym;
  495. {
  496.     NODE *cls,*lptr;
  497.     int base,varnum;
  498.     int found;
  499.  
  500.     /* get the class of the object */
  501.     cls = obj->n_obclass;
  502.  
  503.     /* get the total number of instance variables */
  504.     base = getivcnt(cls,IVARTOTAL);
  505.  
  506.     /* find the variable */
  507.     found = FALSE;
  508.     for (; cls != NULL; cls = xlgetivar(cls,SUPERCLASS)) {
  509.  
  510.     /* get the number of instance variables for this class */
  511.     if ((base -= getivcnt(cls,IVARCNT)) < 0)
  512.         xlfail("error finding instance variable");
  513.  
  514.     /* check for finding the class of the current message */
  515.     if (!found && cls == msgclass->n_symvalue)
  516.         found = TRUE;
  517.  
  518.     /* lookup the instance variable */
  519.     varnum = 0;
  520.     for (lptr = xlgetivar(cls,IVARS);
  521.              lptr != NULL;
  522.              lptr = cdr(lptr))
  523.         if (found && car(lptr) == sym)
  524.         return (xlivar(obj,base + varnum));
  525.         else
  526.         varnum++;
  527.  
  528.     /* skip the class variables if the message class hasn't been found */
  529.     if (!found)
  530.         continue;
  531.  
  532.     /* lookup the class variable */
  533.     varnum = 0;
  534.     for (lptr = xlgetivar(cls,CVARS);
  535.              lptr != NULL;
  536.              lptr = cdr(lptr))
  537.         if (car(lptr) == sym)
  538.         return (xlcvar(cls,varnum));
  539.         else
  540.         varnum++;
  541.     }
  542.  
  543.     /* variable not found */
  544.     return (NULL);
  545. }
  546.  
  547. /* checkvar - check for an existing class or instance variable */
  548. LOCAL int checkvar(cls,sym)
  549.   NODE *cls,*sym;
  550. {
  551.     NODE *lptr;
  552.  
  553.     /* find the variable */
  554.     for (; cls != NULL; cls = xlgetivar(cls,SUPERCLASS)) {
  555.  
  556.     /* lookup the instance variable */
  557.     for (lptr = xlgetivar(cls,IVARS);
  558.              lptr != NULL;
  559.              lptr = cdr(lptr))
  560.         if (car(lptr) == sym)
  561.         return (TRUE);
  562.  
  563.     /* lookup the class variable */
  564.     for (lptr = xlgetivar(cls,CVARS);
  565.              lptr != NULL;
  566.              lptr = cdr(lptr))
  567.         if (car(lptr) == sym)
  568.         return (TRUE);
  569.     }
  570.  
  571.     /* variable not found */
  572.     return (FALSE);
  573. }
  574.  
  575. /* xlgetivar - get the value of an instance variable */
  576. NODE *xlgetivar(obj,num)
  577.   NODE *obj; int num;
  578. {
  579.     return (car(xlivar(obj,num)));
  580. }
  581.  
  582. /* xlsetivar - set the value of an instance variable */
  583. NODE *xlsetivar(obj,num,val)
  584.   NODE *obj; int num; NODE *val;
  585. {
  586.     rplaca(xlivar(obj,num),val);
  587.     return (val);
  588. }
  589.  
  590. /* xlivar - get an instance variable */
  591. NODE *xlivar(obj,num)
  592.   NODE *obj; int num;
  593. {
  594.     NODE *ivar;
  595.  
  596.     /* get the instance variable */
  597.     for (ivar = obj->n_obdata; num > 0; num--)
  598.     if (ivar != NULL)
  599.         ivar = cdr(ivar);
  600.     else
  601.         xlfail("bad instance variable list");
  602.  
  603.     /* return the instance variable */
  604.     return (ivar);
  605. }
  606.  
  607. /* xlcvar - get a class variable */
  608. NODE *xlcvar(cls,num)
  609.   NODE *cls; int num;
  610. {
  611.     NODE *cvar;
  612.  
  613.     /* get the class variable */
  614.     for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
  615.     if (cvar != NULL)
  616.         cvar = cdr(cvar);
  617.     else
  618.         xlfail("bad class variable list");
  619.  
  620.     /* return the class variable */
  621.     return (cvar);
  622. }
  623.  
  624. /* makelist - make a list of nodes */
  625. LOCAL NODE *makelist(cnt)
  626.   int cnt;
  627. {
  628.     NODE *oldstk,list,*lnew;
  629.  
  630.     /* create a new stack frame */
  631.     oldstk = xlsave(&list,NULL);
  632.  
  633.     /* make the list */
  634.     for (; cnt > 0; cnt--) {
  635.     lnew = newnode(LIST);
  636.     rplacd(lnew,list.n_ptr);
  637.     list.n_ptr = lnew;
  638.     }
  639.  
  640.     /* restore the previous stack frame */
  641.     xlstack = oldstk;
  642.  
  643.     /* return the list */
  644.     return (list.n_ptr);
  645. }
  646.  
  647. /* xloinit - object function initialization routine */
  648. xloinit()
  649. {
  650.     /* don't confuse the garbage collector */
  651.     class = NULL;
  652.     object = NULL;
  653.  
  654.     /* enter the object related symbols */
  655.     new        = xlsenter("new");
  656.     isnew    = xlsenter("isnew");
  657.     self    = xlsenter("self");
  658.     msgclass    = xlsenter("msgclass");
  659.  
  660.     /* create the 'Class' object */
  661.     class = xlclass("Class",CLASSSIZE);
  662.     class->n_obclass = class;
  663.  
  664.     /* create the 'Object' object */
  665.     object = xlclass("Object",0);
  666.  
  667.     /* finish initializing 'class' */
  668.     xlsetivar(class,SUPERCLASS,object);
  669.     xladdivar(class,"ivartotal");    /* ivar number 6 */
  670.     xladdivar(class,"ivarcnt");        /* ivar number 5 */
  671.     xladdivar(class,"superclass");    /* ivar number 4 */
  672.     xladdivar(class,"cvals");        /* ivar number 3 */
  673.     xladdivar(class,"cvars");        /* ivar number 2 */
  674.     xladdivar(class,"ivars");        /* ivar number 1 */
  675.     xladdivar(class,"messages");    /* ivar number 0 */
  676.     xladdmsg(class,"new",mnew);
  677.     xladdmsg(class,"answer",answer);
  678.     xladdmsg(class,"ivars",mivars);
  679.     xladdmsg(class,"cvars",mcvars);
  680.     xladdmsg(class,"isnew",misnew);
  681.  
  682.     /* finish initializing 'object' */
  683.     xladdmsg(object,"class",getclass);
  684.     xladdmsg(object,"show",obshow);
  685.     xladdmsg(object,"isnew",defisnew);
  686.     xladdmsg(object,"sendsuper",sendsuper);
  687. }
  688.